home *** CD-ROM | disk | FTP | other *** search
/ BBS in a Box 3 / BBS in a box - Trilogy III.iso / Files / Prog / D-G / FORTRAN Goodies / String Utilities / CharWord.f next >
Encoding:
Text File  |  1990-12-05  |  2.1 KB  |  100 lines  |  [TEXT/MPS ]
  1. c
  2. c     Returns the N-th word (space delimited)
  3. c
  4. c     Function CharWord
  5. c        Takes a character and an integer*4 word number as input.
  6. c        Returns a character*(*) (word n) as result.
  7. c        note: words are separated by whitespace
  8. c
  9. c    Example provided for owners of Language Systems FORTRAN
  10. c    © 1990 Language Systems Corp.
  11. c
  12. c    Adapted from a routine in Wild Things.
  13. c
  14.      character*(*) function CharWord(theCharacter,theWordNumber)
  15.         
  16. C        receive the argument by Descriptor
  17.  
  18.     structure /DescRec/
  19.         pointer /character*1/ DataPtr
  20.         integer*2 DataSize
  21.         integer*2 SymT
  22.     end structure
  23.     record /DescRec/ theCharacter
  24.  
  25.     integer*4         chard,strngd
  26.     parameter         (chard=18,strngd=19)
  27.  
  28.     integer*4        CharacterLen,theWordNumber
  29.     integer*4        Word,startC,stopC
  30.     logical*4        WhiteSpace
  31.     
  32.     pointer    /character*1/ ptr1,ptr2,ptr3
  33.  
  34. C put the address of the characters into a local variable
  35.     
  36.     ptr1 = theCharacter.DataPtr
  37.  
  38. C store the size
  39.  
  40.     CharacterLen = theCharacter.DataSize
  41.  
  42. c skip any words we don't want
  43.  
  44.     ptr2 = ptr1
  45.     Word = 1
  46.     do while (Word < theWordNumber)
  47.         do while ((WhiteSpace(ptr2)) .and. ((ptr2-ptr1) < CharacterLen))
  48.             ptr2 = ptr2 + 1
  49.         end do
  50.         do while ((.not. WhiteSpace(ptr2)) .and. ((ptr2-ptr1) < CharacterLen))
  51.             ptr2 = ptr2 + 1
  52.         end do
  53.         Word = Word + 1
  54.     end do
  55.  
  56. c skip any white space before desired word
  57.  
  58.     do while ((WhiteSpace(ptr2)) .and. ((ptr2-ptr1) < CharacterLen))
  59.         ptr2 = ptr2 + 1
  60.     end do
  61.     startC = 1 + (ptr2 - ptr1)
  62.     
  63. c find the end of the word
  64.  
  65.     ptr3 = ptr2
  66.     do while ((.not. WhiteSpace(ptr3)) .and. ((ptr3-ptr1) < CharacterLen))
  67.         ptr3 = ptr3 + 1
  68.     end do
  69.     stopC = startC + (ptr3 - ptr2) - 1
  70.     if (stopC < startC) stopC = startC
  71.  
  72. c return the word (turn range checking off)
  73. !!R-
  74.     CharWord = ptr1^(startC:stopC)
  75.     
  76.     return
  77.     end
  78. c
  79. c**************************************************c
  80. c
  81. c Function WhiteSpace
  82. c    Takes a pointer to a character as input.
  83. c    Returns a logical*4 TRUE if the character
  84. c      is a tab,return or space.
  85. c
  86.     logical*4 function WhiteSpace(ptr)
  87.     
  88.     pointer /byte/ ptr
  89.     
  90.     select case(ptr^)
  91.         case(9,13,32)    !ASCII values of tab, return, space
  92.             WhiteSpace = .true.
  93.         case default
  94.             WhiteSpace = .false.
  95.     end select
  96.     return
  97.     end
  98. c
  99. c****************************************c
  100.